/*
 *	Plurals
 *
 *	Author:	S.C.Merrall
 *
 *	File:	mp_main.m
 *
 *	Contents:	mp_main	
 *			mp_init
 *			load_plural
 *
 *	Description:	To remove the need for a sepaerate plural wrapper
 *			for each primitive supplied all functions executed
 *			via this function which can take a variable number
 *			of arguments and reduces the code size
 *
 *	Change History:
 *
 *	Date   Name Comment
 *    -------- ---- -------
 *    29:04:91 SCM  Created
 *    16:05:91 SCM  Renamed from mp_lispobject.m to mp_main.m
 *    16:05:91 SCM  Renamed mp_lispop to mp_main
 *    16:05:91 SCM  Moved load_plural from mp_vax_comms.m
 *    17:05:91 SCM  Added mp_init
 *
 */

#include <mpl.h>
#include <stdio.h>

#include "constant.h"

#include "mp_object.h"
#include "mp_debug.h"
#include "mp_mem_mgmt.h"
#include "mp_main.h"
#include "mp_gc.h"
#include "mp_op_id.h"

#define DEBUG(x) x

plural natural context_stack;

/*----------------------------------------------------------------------------*
 * Function   : mp_init
 *
 * Parameters : void
 *
 * Description:    Creates base of context stack
 *
 * Result     : int:	FAIL/SUCCESS
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int mp_init( void )

#else

visible int mp_init( )

#endif

{
  MP_PluralHeap MPPH_context_stack;
  MP_PluralHeap MPPH_true;
  MP_PluralHeap MPPH_nil;
  plural natural true;
  plural natural nil;
DBG_CALL("mp_init");
DBG_ARGS(fprintf(dbg,"void"));

  OA_to_offsets(MPPH_true) = &true;
  OA_to_offsets(MPPH_nil) = &nil;
  OA_to_offsets(MPPH_context_stack) = &context_stack;

  if (make_integer(MPPH_true) == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to make true for context stack base"));
    return FAIL;
  }
  
  *(plural int *plural) OA_data(MPPH_true) = (plural natural) 1;
  nil = (plural natural) NIL;
  
  if (cons(MPPH_true,MPPH_nil,MPPH_context_stack) == FAIL) {

DBG_FAIL(fprintf(dbg,"FAIL: Unable to cons base of context stack"));
    return FAIL;
  }

  /* OF_destroy(MPP_context_stack) */

DBG_EXIT(fprintf(dbg,"SUCCESS"));
  return SUCCESS;
}

/*----------------------------------------------------------------------------*
 * Function   : mp_main
 *
 * Parameters : int operator_id:	Constant identifier for desired op
 * 		int no_of_args:		Number of arguments
 *		object MPP_arg1:	MasPar Plural Objects for arguments
 *		object MPP_arg2:	(At this time a maximum of two)
 *		object MPP_arg3:	(Now a maximum of three)
 *
 * Description: Big switch statement to apply the desired function to the
 *		given arguments and return the result
 *
 * Result     : object MPP_result;
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible object mp_main( int operator_id, int no_of_args,
			  object MPP_arg1, object MPP_arg2, object MPP_arg3 )

#else

visible object mp_main( operator_id, no_of_args, 
			  MPP_arg1, MPP_arg2, MPP_arg3 )

int operator_id;
int no_of_args;
object MPP_arg1;
object MPP_arg3;
object MPP_arg2;

#endif

{
  object MPP_result;
  MP_PluralHeap MPPH_arg1;	/* C-stack allocate Plural Heap */
  MP_PluralHeap MPPH_arg2;	/* objects, handles on the heap */
  MP_PluralHeap MPPH_result;	/* space of each operand	*/
  MP_PluralHeap MPPH_arg3;
  MP_PluralHeap MPPH_context;
  MP_PluralHeap MPPH_bool;
  plural natural bool;
  int result_status;
  int transferred;
DBG_CALL("mp_main");
DBG_ARGS(fprintf(dbg,"operator_id=%d, no_of_args=%d, MPP_arg1=%04x, MPP_arg2=%04x",operator_id,no_of_args,MPP_arg1,MPP_arg2));

  /* If more than one argument check they are conformant */

  if (no_of_args >= 2) {

    if (!OF_conformant_p(MPP_arg1,MPP_arg2)) {

DBG_EXIT(fprintf(dbg,"FAIL: plurals are not conformant"));
      return FAIL;
    }
  }

  /* Create new Plural for the result */

  if ((MPP_result = alloc_plural( MPP_arg1, 0 )) == FAIL) {

DBG_EXIT(fprintf(dbg,"FAIL: unable to allocate plural"));
    return FAIL;
  }

  OA_to_offsets(MPPH_context) = &context_stack;
/*print(MPPH_context,(plural int) 0);
fprintf(stdout,"#P( ");
p_fprintf(stdout,"%s ",scratch);
fprintf(stdout,")\n");*/

  OA_to_offsets(MPPH_bool) = &bool;

  if (car(MPPH_context, MPPH_bool) == FAIL) {
   
DBG_FAIL(fprintf(dbg,"FAIL: Unable to take car of context stack"));
    return FAIL;
  }
 


  if (no_of_args >= 1) MPP_2_MPPH(MPPH_arg1,MPP_arg1);
  if (no_of_args >= 2) MPP_2_MPPH(MPPH_arg2,MPP_arg2);
  if (no_of_args >= 3) MPP_2_MPPH(MPPH_arg3,MPP_arg3);
  MPP_2_MPPH(MPPH_result,MPP_result);

  scratch[(plural int) 0] = (plural natural) NULL;

  if (/**(plural int *plural) OA_data(MPPH_bool) == */1) {
  
  OF_on_plural(MPP_arg1) {

    switch (operator_id) {

    case MP_MAKE_INTEGER :

      result_status = make_integer( MPPH_arg1 );
fprintf(dbg,"object_type = %x\n",MPPH_result->Generic.object_type);
      OF_destroy(MPP_result);
      MPP_result = MPP_arg1;
      break;

    case MP_PLUS :

      result_status = plus( MPPH_arg1, MPPH_arg2, MPPH_result );
      break;

    case MP_LESS_THAN :

      result_status = less_than( MPPH_arg1, MPPH_arg2, MPPH_result );
      break;

    case MP_MP_CONS :
      
      result_status = cons( MPPH_arg1, MPPH_arg2, MPPH_result );
      break;

    case MP_CAR :

      result_status = car( MPPH_arg1, MPPH_result );
      break;
      
    case MP_CDR :

      result_status = cdr( MPPH_arg1, MPPH_result );
      break;
      
    case MP_RPLAC_A :

      result_status = rplac_a( MPPH_arg1, MPPH_arg2 );
      OF_destroy(MPP_result);
      MPP_result = MPP_arg1;
      break;

    case MP_RPLAC_D :

      result_status = rplac_d( MPPH_arg1, MPPH_arg2 );
      OF_destroy(MPP_result);
      MPP_result = MPP_arg1;
      break;

    case MP_PRINT :

      scratch[(plural int) 0] = (plural int) NULL;
      print( MPPH_arg1,(plural int) 0 ); 
/*      fprintf(stdout, "#P( ");
      p_fprintf(stdout, "%s ", scratch);
      fprintf(stdout, ")\n");
*/      OF_destroy(MPP_result);
/*      transferred = blockOut(scratch,MPP_arg2,0,0,nxproc,nyproc,64);
*/      MPP_result = MPP_arg1;
      result_status = SUCCESS;
      break;

    case MP_ASSIGN :
      
      /* Here arg2 is not an object but represents an integer */

      *(plural int *plural)OA_data(MPPH_arg1) = (plural int) MPP_arg2;
      OF_destroy(MPP_result);
      MPP_result=MPP_arg1;
      result_status = SUCCESS;
      break;
	
    case MP_MAKE_MP_VECTOR :

     /*  In this case, argument two is not an object (i.e. address) but
      *  a 32 bit integer indicating the size of vector to be allocated.
      */

      make_vector( (plural int) MPP_arg2, MPPH_arg1 );
      OF_destroy(MPP_result);
      MPP_result = MPP_arg1;
      break;

    case MP_MP_VECTOR_SET :

      /* Check argument 2 are integers */

      if (globalor(OA_info(MPPH_arg2) != INTEGER)) {

DBG_EXIT(fprintf(dbg,"FAIL: Some of the indexes are not integers"));
        result_status = FAIL;
      }
      else {
	
	result_status = vector_set( MPPH_arg1, 
				    *(plural int *plural) OA_data(MPPH_arg2), 
				    MPPH_arg3);
	OF_destroy(MPP_result);
	MPP_result = MPP_arg1;
      }
      break;

    case MP_MP_VECTOR_REF :

      /* Check argument 2 are integers */

      if (globalor(OA_info(MPPH_arg2) != INTEGER)) {

DBG_EXIT(fprintf(dbg,"FAIL: Some of the indexes are not integers"));
        result_status = FAIL;
      }
      else {
      
	result_status = vector_ref( MPPH_arg1, 
				    *(plural int *plural) OA_data(MPPH_arg2), 
				    MPPH_result);
      }
      break;

    case MP_IF :

      OA_to_offsets(MPPH_result) = &context_stack;
      result_status = mp_if( MPPH_arg1, MPPH_result );
      break;

    default:
      
      result_status = FAIL;
    }
  }
  }
    
  if (result_status == FAIL) {

    OF_destroy(MPP_result);
DBG_EXIT(fprintf(dbg,"FAIL: in op or unknown op"));
    return FAIL;
  }

  if (operator_id = MP_PRINT) return scratch;

DBG_EXIT(fprintf(dbg,"%04x",MPP_result));
  return MPP_result;
}


/*----------------------------------------------------------------------------*
 * Function   : load_plural
 *
 * Parameters : object MPP_into:	MasPar Plural Object to load data into
 *		void *fe_start:		Front End address of where data starts
 *		int size:		How much is to go onto each element
 *
 * Description:    Load the given plural with data copied from the front end.
 *		The same quantity of data is to be loaded onto each PE. The
 *		first PE takes its data from fe_start, the next PE from 
 *		fe_start + size and so on. The data is copied into scratch
 *		before being copied to its destination. When things lagere
 *		tahn the scratch memory are loaded the load is done in several 
 *		passes.
 *
 * Result     : int:	SUCCESS - all went well
 *	      :		FAIL    - something amiss - shouldn't be memory as this
 *				  will have been allocated before calling load.
 *---------------------------------------------------------------------------*/

#ifdef __STDC__

visible int load_plural( object MPP_into, char *fe_start, int size )

#else

visible int load_plural( MPP_into, fe_start, size )

object MPP_into;
char *fe_start;
int size;

#endif

{
  char *fe_start2, *fe_start3;
  plural char *plural copy_to;
  plural heap_header headers;
  int size_to_copy;
  int x_rec1;                   /* x coord of first element */
  int lx_rec1;                  /* width of first rectangle */
  int y_rec1;                   /* y coord of first element */
  int ly_rec2;                  /* height of rectangle2 in  */
  int lx_rec3;			/* width of last rectangle  */
  int processors_read = 0;      /* No of processors read after each rectangle*/
  int result;

DBG_CALL("load_plural");
DBG_ARGS(fprintf(dbg,"MPP_into=%lx, fe_start=%lx, size=%d",
		      MPP_into,fe_start,size));

  OF_on_plural(MPP_into) {

    /* Check the load is possible                 */
    /* Does the plural have space allocated to it */

    if (globalor(OF_plural_cmpt(MPP_into) == NIL)) {

DBG_EXIT(fprintf(dbg,"FAIL: Some elements have no memory"));
      return FAIL;
    }

    /* The plural memory hasn't been inadvertently freed has it? */

    headers = OF_header_cmpt(MPP_into);
    
    if (globalor(HH_free(headers) == TRUE)) {

DBG_EXIT(fprintf(dbg,"FAIL: Some elements heap space has been freed"));
      return FAIL;
    }

    /* The plural heap space is all big enough isn't it   ?        */

    if (globalor(((HH_space(headers) * 4) < size )) {

DBG_EXIT(fprintf(dbg,"FAIL: Some elements have insufficient space"));
      return FAIL;

    }

    /* Okay " Al est esfertag " */ 

    /* This next part is a hack: identify at most three rectangles that */
    /* describe the plurals on the array. We allocate sequentially -    */
    /* it works as though its a grid - this has serious implications    */
    /* for the alocation algorithm.                                     */

    processors_read = 0;
    x_rec1 = proc[(int) OA_start(MPP_into)].ixproc;
    y_rec1 = proc[(int) OA_start(MPP_into)].iyproc;
    if ((x_rec1 + OA_length(MPP_into)) < nxproc) 
      lx_rec1 = OA_length(MPP_into) ;
    else
      lx_rec1 = nxproc - x_rec1;
    processors_read = lx_rec1;
    fe_start2 = processors_read * size + fe_start;
    ly_rec2 = (OA_length(MPP_into) - processors_read) / nxproc;
    processors_read = processors_read + ly_rec2 * nxproc;
    fe_start3 = fe_start + processors_read * size;
    lx_rec3 = OA_length(MPP_into) - processors_read;

    copy_to = OF_data_cmpt(MPP_into);

DEBUG(fprintf(dbg,"x_rec1=%d, y_rec1 = %d\n",x_rec1,y_rec1));
DEBUG(fprintf(dbg,"lx_rec1=%d, ly_rec2=%d\n",lx_rec1,ly_rec2));
DEBUG(fprintf(dbg,"lx_rec3=%d\n",lx_rec3));
DEBUG(fprintf(dbg,"fe_start2=%lx, fe_start3=%lx\n",fe_start2,fe_start3));

    for ( ; size > 0; size = size - size_to_copy) {
      
      if (size > SCRATCH_MEMORY_SIZE) size_to_copy = SCRATCH_MEMORY_SIZE;
      else size_to_copy = size;

      result = blockIn(fe_start,scratch,x_rec1,y_rec1,lx_rec1,1,size_to_copy);
DEBUG(fprintf(dbg,"Number of bytes copied = %d\n",result));

      if (result == -1) {
DBG_EXIT(fprintf(dbg,"FAIL: for rectangle1 (%d,%d)(%d,1)",x_rec1,y_rec1,lx_rec1));
	return FAIL;
      }

      if (ly_rec2 > 0) {

	result = blockIn(fe_start2,
			 scratch,0,y_rec1+1,nxproc,ly_rec2,size_to_copy);

  	if (result == -1) {
DBG_EXIT(fprintf(dbg,"FAIL: for rectangle2 (0,%d)(%d,%d)",y_rec1+1,nxproc,ly_rec2));
	  return FAIL;
	}
      }

      if (lx_rec3 > 0) {

	result = blockIn(fe_start3,
		         scratch,0,y_rec1+1+ly_rec2,lx_rec3,1,size_to_copy);

	if (result == -1) {
DBG_EXIT(fprintf(dbg,"FAIL: for rectangle3 (0,%d)(%d,1)",y_rec1+1+ly_rec2,lx_rec3));
	   return FAIL;
	}
      }
      pp_memcpy(copy_to, (plural char *plural) scratch, (plural int) size_to_copy );
      copy_to = copy_to + size_to_copy;
    }
  }

DEBUG(p_dbg_print("scratch[0]",0,16,"%02x ",(plural natural) scratch[0]));
DEBUG(p_dbg_print("scratch[1]",0,16,"%02x ",(plural natural) scratch[1]));
DEBUG(p_dbg_print("scratch[2]",0,16,"%02x ",(plural natural) scratch[2]));
DEBUG(p_dbg_print("scratch[3]",0,16,"%02x ",(plural natural) scratch[3]));

DBG_EXIT(fprintf(dbg,"SUCCESS"));
  return SUCCESS;
}



